home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / vectors.c < prev    next >
C/C++ Source or Header  |  1993-06-14  |  6KB  |  275 lines
  1. /* ******************************************************************** */
  2. /*  vector.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  Wild thing                                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: vectors.c,v 1.6 1992/11/26 16:13:51 pab Exp $
  9.  *
  10.  * $Log: vectors.c,v $
  11.  * Revision 1.6  1992/11/26  16:13:51  pab
  12.  * Correct type check
  13.  *
  14.  * Revision 1.5  1992/06/16  19:31:54  pab
  15.  * added primitive operations
  16.  *
  17.  * Revision 1.4  1992/01/09  22:29:12  pab
  18.  * Fixed for low tag ints
  19.  *
  20.  * Revision 1.3  1991/12/22  15:14:46  pab
  21.  * Xmas revision
  22.  *
  23.  * Revision 1.2  1991/09/11  12:07:52  pab
  24.  * 11/9/91 First Alpha release of modified system
  25.  *
  26.  * Revision 1.1  1991/08/12  16:50:13  pab
  27.  * Initial revision
  28.  *
  29.  * Revision 1.3  1991/02/13  18:27:11  kjp
  30.  * Pass.
  31.  *
  32.  */
  33.  
  34. #define KJPDBG(x) 
  35.  
  36. /*
  37.  * Change Log:
  38.  *   Version 1, October 1989
  39.  *   Hacked everything - not robust ( even slightly ) (24/10/89) KJP
  40.  *   Properly + GC protect (hopefully) 
  41.  *
  42.  *   Garbage checked - OK.
  43.  */
  44.  
  45. #include <stdio.h>
  46. #include "funcalls.h"
  47. #include "defs.h"
  48. #include "structs.h"
  49. #include "global.h"
  50. #include "error.h"
  51. #include "bootstrap.h"
  52.  
  53. /* Modulise: allocation */
  54.  
  55. #include "modboot.h"
  56.  
  57. #define VECTORS_ENTRIES 11
  58.  
  59. MODULE     Module_vectors;
  60. LispObject Module_vectors_values[VECTORS_ENTRIES];
  61.  
  62. static LispObject maximum_vector_index;
  63.  
  64. /* End Modulise: allocation*/
  65.  
  66.  
  67. EUFUN_1( Fn_vectorp, obj)
  68. {
  69.   return(is_vector(obj) ? lisptrue : nil);
  70. }
  71. EUFUN_CLOSE
  72.  
  73. EUFUN_2( Fn_make_vector, n, obj)
  74. {
  75.   LispObject vector;
  76.   int i;
  77.  
  78.   while (!is_fixnum(n)) 
  79.     n = CallError(stacktop,
  80.           "Non-integer vector length in 'make-vector'",n,CONTINUABLE);
  81.  
  82.   if (intval(n) < 0)
  83.     CallError(stacktop,
  84.           "Non-positive vector length in 'make-vector'",n,NONCONTINUABLE);
  85.  
  86. /*
  87.   if (intval(n) == 0) return(nil);
  88. */
  89.  
  90.   if (intval(n) > intval(maximum_vector_index))
  91.     CallError(stacktop,
  92.           "Vector length in 'make-vector' too large",n,NONCONTINUABLE);
  93.  
  94.   /* For the moment using object as an initialisation argument */
  95.  
  96.   vector = (LispObject) allocate_vector(stacktop,intval(n));
  97.  
  98.   obj = ARG_1(stackbase);
  99.   for (i = 0; i < intval(n); ++i) vrefupdate(vector,i,obj);
  100.  
  101.   return(vector);
  102. }
  103. EUFUN_CLOSE
  104.  
  105. EUFUN_2( Fn_make_vector_optional, n, args)
  106. {
  107.   return(EUCALL_2(Fn_make_vector,n,(args == nil ? nil : CAR(args))));
  108. }
  109. EUFUN_CLOSE
  110.  
  111. EUFUN_1( Fn_vector_length, vect)
  112. {
  113.   LispObject len;
  114.  
  115.   while (!is_vector(vect))
  116.     vect = CallError(stacktop,
  117.              "Non-vector in 'vector-length'",vect,CONTINUABLE);
  118.  
  119.   len = (LispObject) allocate_integer(stacktop,vect->VECTOR.length);
  120.   
  121.   return(len);
  122. }
  123. EUFUN_CLOSE
  124.  
  125. EUFUN_2( Fn_vector_ref, vect, n)
  126. {
  127.   while (!is_vector(vect))
  128.     vect = CallError(stacktop,
  129.              "Non-vector in 'vector-ref'", vect, CONTINUABLE);
  130.  
  131.   while (!is_fixnum(n))
  132.     vect = CallError(stacktop,
  133.              "Non-integer in 'vector-ref'",
  134.              ARG_1(stackbase), CONTINUABLE );
  135.  
  136.   n = ARG_1(stackbase);
  137.   if (intval(n) < 0 || intval(n) >= vect->VECTOR.length)
  138.     CallError(stacktop,"Index out of range in 'vector-ref'",n,NONCONTINUABLE);
  139.   
  140.   return(vref(vect,intval(n)));
  141. }
  142. EUFUN_CLOSE
  143.  
  144. EUFUN_3( Fn_vector_ref_updator, vect, n, obj)
  145. {
  146.   while (!is_vector(vect))
  147.     vect = CallError(stacktop,
  148.              "Non-vector in 'vector-ref-updator'", vect, CONTINUABLE);
  149.  
  150.   while (!is_fixnum(n))
  151.     vect = CallError(stacktop,
  152.              "Non-integer in 'vector-ref-updator'",
  153.              ARG_1(stackbase), CONTINUABLE );
  154.  
  155.   n = ARG_1(stackbase);
  156.   if (intval(n) < 0 || intval(n) >= vect->VECTOR.length)
  157.     CallError(stacktop,
  158.           "Index out of range in 'vector-ref-updator'",n,NONCONTINUABLE);
  159.  
  160.   vect = ARG_0(stackbase);
  161.   obj = ARG_2(stackbase);
  162.   vrefupdate(vect,intval(n),obj);
  163.  
  164.   return(obj);
  165. }
  166. EUFUN_CLOSE
  167.  
  168. EUFUN_1( Fn_vector, forms)
  169. {
  170.   LispObject vect;
  171.   int i, vlen;
  172.  
  173. /*
  174.   if (forms == nil)
  175.     CallError("Can't make zero length vector in 'vector'",nil,NONCONTINUABLE);
  176. */
  177.  
  178.   EUCALLSET_1(vect, Fn_length, forms);
  179.   vlen = intval(vect);
  180.   vect = (LispObject) allocate_vector(stacktop,vlen);
  181.  
  182.   forms = ARG_0(stackbase);
  183.   for (i = 0; i < vlen; ++i) {
  184.     vrefupdate(vect,i,CAR(forms));
  185.     forms = CDR( forms );
  186.   }
  187.  
  188.   return(vect);
  189. }
  190. EUFUN_CLOSE
  191.  
  192. /* This should just be a method to 'convert' when it exists */
  193.  
  194. EUFUN_1( Fn_convert_vector_list, vect )
  195. {
  196.   LispObject newlist;
  197.   int i;
  198.  
  199.   while (!is_vector(vect)) {
  200.     vect = CallError(stacktop,
  201.              "Non-vector in vector coercion", vect, CONTINUABLE );
  202.   }
  203.  
  204.   newlist = nil;
  205.   for ( i = vect->VECTOR.length; i > 0; --i ) {
  206.     ARG_0(stackbase) = vect;
  207.     EUCALLSET_2(newlist, Fn_cons, vref( vect, i-1 ), newlist );
  208.     vect = ARG_0(stackbase);
  209.   }
  210.  
  211.   return( newlist );
  212. }
  213. EUFUN_CLOSE
  214.  
  215. EUFUN_2(Fn_make_primitive_object, class, size)
  216. {
  217.   LispObject tmp;
  218.  
  219.   tmp=allocate_vector(stacktop,intval(size));
  220.   lval_classof(tmp)=class;
  221.   
  222.   return tmp;
  223.  
  224. }
  225. EUFUN_CLOSE
  226.  
  227. EUFUN_2(Fn_primitive_ref, o, n)
  228. {
  229.   return vref(o,intval(n));
  230. }
  231. EUFUN_CLOSE
  232.  
  233. EUFUN_3(Fn_primitive_ref_setter, o, n ,v)
  234. {
  235.   vref(o,intval(n))=v;
  236.   
  237.   return v;
  238.  
  239. }
  240. EUFUN_CLOSE
  241.  
  242.  
  243. void initialise_vectors(LispObject* stacktop)
  244. {
  245.   LispObject getter, setter;
  246.  
  247.   /* Modulise: initialisation */
  248.  
  249.   open_module(stacktop,
  250.           &Module_vectors,Module_vectors_values,"vectors",VECTORS_ENTRIES);
  251.  
  252.   (void) make_module_function(stacktop,"vectorp",Fn_vectorp,1);
  253.   (void) make_module_function(stacktop,
  254.                   "make-vector",Fn_make_vector_optional,-2);
  255.   (void) make_module_function(stacktop,"vector-length",Fn_vector_length,1);
  256.   getter = make_module_function(stacktop,"vector-ref",Fn_vector_ref,2);
  257.   STACK_TMP(getter);
  258.   setter = make_module_function(stacktop,
  259.                 "vector-ref-updator",Fn_vector_ref_updator,3);
  260.   UNSTACK_TMP(getter);
  261.   set_anon_associate(stacktop,getter,setter);
  262.   (void) make_module_function(stacktop,"make-initialized-vector",Fn_vector,-1);
  263.   (void) make_module_function(stacktop,
  264.                   "convert-vector-list",Fn_convert_vector_list,1);
  265.   maximum_vector_index = allocate_integer(stacktop,0xfffff);
  266.   add_root(&maximum_vector_index);
  267.  
  268.   (void) make_module_entry(stacktop,"*maximum-vector-index*",maximum_vector_index);
  269.  
  270.   (void) make_module_function(stacktop,"make-primitive-object",Fn_make_primitive_object,3);
  271.   (void) make_module_function(stacktop,"primitive-ref",Fn_primitive_ref,2);
  272.   (void) make_module_function(stacktop,"set-primitive-ref",Fn_primitive_ref_setter,3);
  273.   close_module();
  274. }
  275.